home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / grind.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  16.4 KB  |  516 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module grind)
  13.  
  14. (declare-top (GENPREFIX GRI)
  15.      (SPECIAL LOP ROP STRING CHRPS $ALIASES ALIASLIST LINEL)
  16.      (FIXNUM (CHRCT))
  17.      (*EXPR LBP RBP))
  18.  
  19. (DEFUN CHRCT () (f- LINEL CHRPS))
  20.  
  21. (DEFUN CHRCT* () (f- LINEL CHRPS))
  22.  
  23. #-MAXII
  24. (DEFVAR ALPHABET '(#\% #\_))
  25. (DEFVAR FORTRANP NIL)
  26.  
  27. ;(DEFMSPEC $GRIND (X) (SETQ X (CDR X))
  28. ;  (LET (Y)
  29. ;    (IF (NOT (ZEROP (CHARPOS T))) (MTERPRI))
  30. ;    (COND ((OR (NULL X) (CDR X)) (WNA-ERR '$GRIND))
  31. ;      ((ATOM (SETQ X (STRMEVAL (CAR X))))
  32. ;       (SETQ X ($VERBIFY X))
  33. ;       (COND ((SETQ Y (MGET X 'MEXPR))
  34. ;          (MGRIND (LIST '(MDEFINE) (CONS (LIST X) (CDADR Y)) (CADDR Y)) NIL))
  35. ;         ((SETQ Y (MGET X 'MMACRO))
  36. ;          (MGRIND (LIST '(MDEFMACRO) (CONS (LIST X) (CDADR Y)) (CADDR Y)) NIL))
  37. ;         ((SETQ Y (MGET X 'AEXPR))
  38. ;          (MGRIND (LIST '(MDEFINE) (CONS (LIST X 'ARRAY) (CDADR Y)) (CADDR Y)) NIL))
  39. ;         (T (MGRIND X NIL)))
  40. ;       (TYO #/$ NIL))
  41. ;      (T (MGRIND X NIL) (TYO #/$ NIL)))
  42. ;    '$DONE))
  43. ;Update from F302 --gsb
  44. (DEFMSPEC $GRIND (X) (SETQ X (CDR X))
  45.   (LET (Y)
  46.     (IF (NOT (ZEROP (CHARPOS T))) (MTERPRI))
  47.     (COND ((OR (NULL X) (CDR X)) (WNA-ERR '$GRIND))
  48.       ((SYMBOLP (SETQ X (STRMEVAL (CAR X))))
  49.        (SETQ X ($VERBIFY X))
  50.        (COND ((SETQ Y (MGET X 'MEXPR))
  51.           (MGRIND (LIST '(MDEFINE) (CONS (LIST X) (CDADR Y)) (CADDR Y)) NIL))
  52.          ((SETQ Y (MGET X 'MMACRO))
  53.           (MGRIND (LIST '(MDEFMACRO) (CONS (LIST X) (CDADR Y)) (CADDR Y)) NIL))
  54.          ((SETQ Y (MGET X 'AEXPR))
  55.           (MGRIND (LIST '(MDEFINE) (CONS (LIST X 'array) (CDADR Y)) (CADDR Y)) NIL))
  56.          (T (MGRIND X NIL)))
  57.        (TYO #\$ NIL))
  58.       (T (MGRIND X NIL) (TYO #\$ NIL)))
  59.     '$DONE))
  60.  
  61. (defun show-msize (lis)
  62.   (format t "~%Length is ~A" (car lis))
  63.   (sloop for v in (cdr lis)
  64.     when (numberp v) do (princ (ascii v))
  65.                     else when (consp v)
  66.         do   (show-msize v)))
  67. ;;Msize returns a list whose first member is the number of characters
  68. ;;in the printed representation of the rest of the list.
  69. ;;thus to print something given it's msize you could
  70. ;;use msize-print if you did not care about line breaks etc.
  71. ;;If you care about them then you should send a newline
  72. ;;if the current distance to the margin is bigger than the first element of lis
  73.  
  74. (defun msize-print (lis)
  75.   (sloop for v in (cdr lis)
  76.     when (numberp v)
  77.       do (princ (ascii v))
  78.     else do (msize-print v)))
  79.  
  80. (defun i-$grind (x)
  81.   (LET (Y)
  82.     (IF (NOT (ZEROP (CHARPOS T))) (MTERPRI))
  83.     (COND  ((SYMBOLP (SETQ X (STRMEVAL  X)))
  84.         (SETQ X ($VERBIFY X))
  85.         (COND ((SETQ Y (MGET X 'MEXPR))
  86.            (MGRIND (LIST '(MDEFINE) (CONS (LIST X) (CDADR Y)) (CADDR Y)) NIL))
  87.           ((SETQ Y (MGET X 'MMACRO))
  88.            (MGRIND (LIST '(MDEFMACRO) (CONS (LIST X) (CDADR Y)) (CADDR Y)) NIL))
  89.           ((SETQ Y (MGET X 'AEXPR))
  90.            (MGRIND (LIST '(MDEFINE) (CONS (LIST X 'array) (CDADR Y)) (CADDR Y)) NIL))
  91.           (T (MGRIND X NIL)))
  92.         (TYO #\$ NIL))
  93.       (T (MGRIND X NIL) (TYO #\$ NIL)))
  94.     '$DONE))
  95.   
  96.  
  97. (DEFUN MGRIND (X OUT)
  98.   (SETQ CHRPS 0)
  99.   (MPRINT (MSIZE X NIL NIL 'MPAREN 'MPAREN) OUT))
  100.  
  101. (DEFUN MPRINT (X OUT)
  102.   (COND (#-cl (INTEGERP X)
  103.      #+cl (characterp x)
  104.     (SETQ CHRPS (f1+ CHRPS)) (TYO X OUT))
  105.     ((< (CAR X) (CHRCT*)) (MAPC #'(LAMBDA (L) (MPRINT L OUT)) (CDR X)))
  106.     (T (PROG (I) (SETQ I CHRPS)
  107.          (MPRINT (CADR X) OUT)
  108.          (COND ((NULL (CDDR X)) (RETURN NIL))
  109.            ((AND (OR (ATOM (CADR X)) (< (CAADR X) (CHRCT*)))
  110.              (OR (> (CHRCT*) (// LINEL 2))
  111.                  (ATOM (CADDR X)) (< (CAADDR X) (CHRCT*))))
  112.             (SETQ I CHRPS)
  113.             (MPRINT (CADDR X) OUT))
  114.            (T (SETQ I (f1+ I)) (SETQ CHRPS 0) (TERPRI OUT)
  115.               (MTYOTBSP I OUT) (MPRINT (CADDR X) OUT)))
  116.          (DO ((L (CDDDR X) (CDR L))) ((NULL L))
  117.          (cond
  118.           ((OR (ATOM (CAR L)) (< (CAAR L) (CHRCT*))) NIL)
  119.           (t (SETQ CHRPS 0) (TERPRI OUT) (MTYOTBSP I OUT)))
  120.          (MPRINT (CAR L) OUT))))))
  121.  
  122. (DEFUN MTYOTBSP (N OUT) (DECLARE (FIXNUM N))
  123.   (SETQ CHRPS (f+ N CHRPS))
  124.   (DO () ((< N 8)) (TYO #\TAB OUT) (SETQ N (f- N 8)))
  125.   (DO () ((< N 1)) (TYO #\SPACE OUT) (SETQ N (f1- N))))
  126.  
  127. (DEFUN STRGRIND (X)
  128.   (LET (STRING (CHRPS 0))
  129.     (STRPRINT (MSIZE X NIL NIL 'MPAREN 'MPAREN))
  130.     (NREVERSE STRING)))
  131.  
  132. (DEFUN STRPRINT (X)
  133.   (COND ((ATOM X) (STYO X))
  134.     ((< (CAR X) (CHRCT*)) (MAPC #'STRPRINT (CDR X)))
  135.     (T (PROG (I)
  136.          (SETQ I CHRPS)
  137.          (STRPRINT (CADR X))
  138.          (COND ((NULL (CDDR X)) (RETURN NIL))
  139.            ((AND (OR (ATOM (CADR X)) (< (CAADR X) (CHRCT*)))
  140.              (OR (> (CHRCT*) (// LINEL 2))
  141.                  (ATOM (CADDR X)) (< (CAADDR X) (CHRCT*))))
  142.             (SETQ I CHRPS)
  143.             (STRPRINT (CADDR X)))
  144.            (T (SETQ I (f1+ I)) (SETQ CHRPS 0) (STERPRI)
  145.               (STYOTBSP I) (STRPRINT (CADDR X))))
  146.          (DO ((L (CDDDR X) (CDR L))) ((NULL L))
  147.          (cond
  148.           ((OR (ATOM (CAR L)) (< (CAAR L) (CHRCT*))) NIL)
  149.           (t (SETQ CHRPS 0) (STERPRI) (STYOTBSP I)))
  150.          (STRPRINT (CAR L)))))))
  151.  
  152. (DEFUN STYO (X) (SETQ STRING (CONS X STRING) CHRPS (f1+ CHRPS)))
  153.  
  154. (DEFUN STERPRI () (SETQ STRING (CONS #\NEWLINE STRING) CHRPS 0))
  155.  
  156. (DEFUN STYOTBSP (N) (DECLARE (FIXNUM N)) (SETQ CHRPS N)
  157.   (DO () ((< N 8)) (SETQ STRING (CONS #\TAB STRING) N (f- N 8)))
  158.   (DO () ((< N 1)) (SETQ STRING (CONS #\SPACE STRING) N (f1- N))))
  159.  
  160. (DEFMFUN MSTRING (X)
  161.   (NREVERSE (STRING1 (MSIZE X NIL NIL 'MPAREN 'MPAREN) NIL)))
  162.  
  163. (DEFUN STRING1 (X L)
  164.   (cond
  165.    ((ATOM X) (CONS X L))
  166.    (t (SETQ X  (CDR X))
  167.       (DO () ((NULL X) L) (SETQ L (STRING1 (CAR X) L) X (CDR X))))))
  168.  
  169.  
  170.  
  171. (DEFUN MSIZE (X L R LOP ROP)
  172.   (SETQ X (NFORMAT X))
  173.   (COND ((ATOM X) (IF FORTRANP (MSZ (MAKESTRING X) L R) (MSIZE-ATOM X L R)))
  174.     ((OR (<= (LBP (CAAR X)) (RBP LOP)) (> (LBP ROP) (RBP (CAAR X))))
  175.      (MSIZE-PAREN X L R))
  176.     ((MEMQ 'array (CDAR X)) (MSIZE-ARRAY X L R))
  177.     ((safe-GET (CAAR X) 'GRIND)
  178.      (the (values t) (FUNCALL (GET (CAAR X) 'GRIND) X L R)))
  179.     (T (MSIZE-FUNCTION X L R NIL))))
  180.  
  181. (DEFUN MSIZE-ATOM (X L R)
  182.   (PROG (Y)
  183.     (COND ((NUMBERP X) (SETQ Y (EXPLODEN X)))
  184.       ((AND (SETQ Y (safe-GET X 'REVERSEALIAS))
  185.         (NOT (AND (MEMQ X $ALIASES) (GET X 'NOUN))))
  186.        (SETQ Y (EXPLODEN Y)))
  187.       ((SETQ Y (ASSQR X ALIASLIST)) (RETURN (MSIZE (CAR Y) L R LOP ROP)))
  188.       ((NULL (SETQ Y (IF (EQ '%DERIVATIVE X)
  189.                  (COPY-TOP-LEVEL '(#\% #\D #\I #\F #\F))
  190.                  (EXPLODEN X)))))
  191.       ((char= #\$ (CAR Y)) (SETQ Y (SLASH (CDR Y))))
  192.       ((char= #\% (CAR Y)) (SETQ Y (SLASH (CDR Y))))
  193.       ((char= #\& (CAR Y))
  194.        (DO ((L (CDR Y) (CDR L))) ((NULL L))
  195.            (COND ((OR (zl-MEMBER (CAR L)
  196.                      '(#. double-quote-char
  197.                       #. back-slash-char
  198.                          #. semi-colon-char #\$))
  199.               (AND (char< (CAR L) #\space)
  200.                    (NOT (char= (CAR L) #\return ;13
  201.                        ))))
  202.               (RPLACD L (CONS (CAR L) (CDR L)))
  203.               (RPLACA L #. back-slash-char) (SETQ L (CDR L)))))
  204.        (SETQ Y (CONS #. double-quote-char (NCONC (CDR Y) (LIST #. double-quote-char)))))
  205.       (T (SETQ Y (CONS #\? (SLASH Y)))))
  206.   (RETURN (MSZ Y L R))))
  207.  
  208. (DEFUN MSZ (X L R) (SETQ X (NRECONC L (NCONC X R))) (CONS (LENGTH X) X))
  209.  
  210. (DEFUN SLASH (X)
  211.   (DO ((L (CDR X) (CDR L))) ((NULL L))
  212.       (IF (or (#+cl ALPHANUMERICP #-cl ALPHANUMP (CAR L))
  213.           (eql (car l) #\_))
  214.           NIL
  215.      (progn (RPLACD L (CONS (CAR L) (CDR L)))
  216.         (RPLACA L #. back-slash-char) (SETQ L (CDR L)))))
  217.   (IF (ALPHABETP (CAR X)) X (CONS #. back-slash-char X)))
  218.  
  219. #-cl
  220. (DEFUN ALPHANUMP (N) (DECLARE (FIXNUM N))
  221.   (OR (ASCII-NUMBERP N) (ALPHABETP N)))
  222.  
  223. (DEFUN MSIZE-PAREN (X L R) (MSIZE X (CONS #. left-parentheses-char L) (CONS #. right-parentheses-char R) 'MPAREN 'MPAREN))
  224.  
  225. ;; The variables LB and RB are not uses here syntactically, but for
  226. ;; communication.  The FORTRAN program rebinds them to #/( and #/) since
  227. ;; Fortran array references are printed with parens instead of brackets.
  228.  
  229. (DEFVAR LB #\[)
  230. (DEFVAR RB #\])
  231.  
  232. (DEFUN MSIZE-ARRAY (X L R &AUX F)
  233.   (IF (EQ (CAAR X) 'MQAPPLY) (SETQ F (CADR X) X (CDR X)) (SETQ F (CAAR X)))
  234.   (COND ((AND (symbolp (CAAR X)) (GET (CAAR X) 'VERB) (GET (CAAR X) 'ALIAS))
  235.      (SETQ L (RECONC '(#\' #\') L)))
  236.     ((AND (symbolp (CAAR X))
  237.           (GET (CAAR X) 'NOUN)
  238.           (NOT (MEMQ (CAAR X) (CDR $ALIASES)))
  239.           (NOT (GET (CAAR X) 'REVERSEALIAS)))
  240.      (SETQ L (CONS #\' L))))
  241.   (SETQ L (MSIZE F L (LIST LB) LOP 'MFUNCTION)
  242.     R (MSIZE-LIST (CDR X) NIL (CONS RB R)))
  243.   (CONS (f+ (CAR L) (CAR R)) (CONS L (CDR R))))
  244.  
  245. (DEFUN MSIZE-FUNCTION (X L R OP)
  246.   (COND ((not (symbolp (caar x))))
  247.     ((AND (GET (CAAR X) 'VERB) (GET (CAAR X) 'ALIAS))
  248.      (SETQ L (RECONC '(#\' #\') L)))
  249.     ((AND (GET (CAAR X) 'NOUN) (NOT (MEMQ (CAAR X) (CDR $ALIASES)))
  250.           (NOT (GET (CAAR X) 'REVERSEALIAS)))
  251.      (SETQ L (CONS #\' L))))
  252.   (SETQ L (MSIZE (IF OP (GETOP (CAAR X)) (CAAR X)) L (NCONS #. left-parentheses-char ) 'MPAREN 'MPAREN)
  253.     R (MSIZE-LIST (CDR X) NIL (CONS #. right-parentheses-char R)))
  254.   (CONS (f+ (CAR L) (CAR R)) (CONS L (CDR R))))
  255.  
  256. (DEFUN MSIZE-LIST (X L R)
  257.   (IF (NULL X) (MSZ NIL L R)
  258.       (DO ((NL) (W 0))
  259.       ((NULL (CDR X))
  260.        (SETQ NL (CONS (MSIZE (CAR X) L R 'MPAREN 'MPAREN) NL))
  261.        (CONS (f+ W (CAAR NL)) (NREVERSE NL)))
  262.       (DECLARE (FIXNUM W))
  263.       (SETQ NL (CONS (MSIZE (CAR X) L (LIST #\,) 'MPAREN 'MPAREN) NL)
  264.         W (f+ W (CAAR NL)) X (CDR X) L NIL))))
  265.  
  266. (DEFUN MSIZE-PREFIX (X L R)
  267.   (MSIZE (CADR X) (RECONC (STRSYM (CAAR X)) L) R (CAAR X) ROP))
  268.  
  269. (DEFUN MSIZE-INFIX (X L R)
  270.   (IF (OR (NULL (CDDR X)) (CDDDR X)) (WNA-ERR (CAAR X)))
  271.   (SETQ L (MSIZE (CADR X) L NIL LOP (CAAR X))
  272.     R (MSIZE (CADDR X) (REVERSE (STRSYM (CAAR X))) R (CAAR X) ROP))
  273.   (LIST (f+ (CAR L) (CAR R)) L R))
  274.  
  275. (DEFUN MSIZE-POSTFIX (X L R)
  276.   (MSIZE (CADR X) L (APPEND (STRSYM (CAAR X)) R) LOP (CAAR X)))
  277.  
  278. (DEFUN MSIZE-NARY (X L R) (MSZNARY X L R (STRSYM (CAAR X))))
  279.  
  280. (DEFUN MSIZE-NOFIX (X L R) (MSIZE (CAAR X) L R (CAAR X) ROP))
  281.  
  282. (DEFUN MSIZE-MATCHFIX (X L R)
  283.   (SETQ L (NRECONC L (CAR (STRSYM (CAAR X))))
  284.     L (CONS (LENGTH L) L)
  285.     R (APPEND (CDR (STRSYM (CAAR X))) R)
  286.     X (MSIZE-LIST (CDR X) NIL R))
  287.   (CONS (f+ (CAR L) (CAR X)) (CONS L (CDR X))))
  288.  
  289. (DEFUN MSZNARY (X L R DISSYM)
  290.  (COND ((NULL (CDDR X)) (MSIZE-FUNCTION X L R T))
  291.        (T (SETQ L (MSIZE (CADR X) L NIL LOP (CAAR X)))
  292.       (DO ((OL (CDDR X) (CDR OL)) (NL (LIST L)) (W (CAR L)))
  293.           ((NULL (CDR OL))
  294.            (SETQ R (MSIZE (CAR OL) (REVERSE DISSYM) R (CAAR X) ROP))
  295.            (CONS (f+ (CAR R) W) (NREVERSE (CONS R NL))))
  296.          (DECLARE (FIXNUM W))
  297.           (SETQ NL (CONS (MSIZE (CAR OL) (REVERSE DISSYM) NIL (CAAR X) (CAAR X))
  298.                  NL)
  299.             W (f+ (CAAR NL) W))))))
  300.  
  301. (DEFUN STRSYM (X) (OR (GET X 'STRSYM) (GET X 'DISSYM)))
  302.  
  303. (DEFPROP BIGFLOAT MSZ-BIGFLOAT GRIND)
  304.  
  305. (DEFUN MSZ-BIGFLOAT (X L R)
  306.   (MSZ (MAPCAR #'(LAMBDA (L) (GETCHARN L 1)) (FPFORMAT X)) L R))
  307.  
  308. (DEFPROP MPROGN MSIZE-MATCHFIX GRIND)
  309. (DEFPROP MLIST MSIZE-MATCHFIX GRIND)
  310.  
  311. (DEFPROP MQAPPLY MSZ-MQAPPLY GRIND)
  312.  
  313. (DEFUN MSZ-MQAPPLY (X L R)
  314.   (SETQ L (MSIZE (CADR X) L (LIST #. left-parentheses-char ) LOP 'MFUNCTION)
  315.     R (MSIZE-LIST (CDDR X) NIL (CONS #. right-parentheses-char R)))
  316.   (CONS (f+ (CAR L) (CAR R)) (CONS L (CDR R))))
  317.  
  318.  
  319. (DEFPROP MQUOTE MSIZE-PREFIX GRIND)
  320. (DEFPROP MQUOTE 201. RBP)
  321. (DEFPROP MSETQ MSIZE-INFIX GRIND)
  322. (DEFPROP MSETQ MSIZE-INFIX GRIND)
  323.  
  324. (DEFPROP MSETQ (#\:) STRSYM)
  325. (DEFPROP MSETQ 180. RBP)
  326. (DEFPROP MSETQ 20. RBP)
  327.  
  328. (DEFPROP MSET MSIZE-INFIX GRIND)
  329. (DEFPROP MSET (#\: #\:) STRSYM)
  330. (DEFPROP MSET 180. LBP)
  331. (DEFPROP MSET 20. RBP)
  332.  
  333. (DEFPROP MDEFINE MSZ-MDEF GRIND)
  334. (DEFPROP MDEFINE (#\: #\=) STRSYM)
  335. (DEFPROP MDEFINE 180. LBP)
  336. (DEFPROP MDEFINE 20. RBP)
  337.  
  338. (DEFPROP MDEFMACRO MSZ-MDEF GRIND)
  339. (DEFPROP MDEFMACRO (#\: #\: #\=) STRSYM)
  340. (DEFPROP MDEFMACRO 180. LBP)
  341. (DEFPROP MDEFMACRO 20. RBP)
  342.  
  343. (DEFUN MSZ-MDEF (X L R)
  344.   (SETQ L (MSIZE (CADR X) L (COPY-TOP-LEVEL (STRSYM (CAAR X))) LOP (CAAR X))
  345.     R (MSIZE (CADDR X) NIL R (CAAR X) ROP))
  346.   (SETQ X (CONS (f- (CAR L) (CAADR L)) (CDDR L)))
  347.   (IF (AND (NOT (ATOM (CADR R))) (NOT (ATOM (CADDR R)))
  348.        (< (f+ (CAR L) (CAADR R) (CAADDR R)) LINEL))
  349.       (SETQ X (NCONC X (LIST (CADR R) (CADDR R)))
  350.         R (CONS (CAR R) (CDDDR R))))
  351.   (CONS (f+ (CAR L) (CAR R)) (CONS (CADR L) (CONS X (CDR R)))))
  352.  
  353.  
  354. (DEFPROP MFACTORIAL MSIZE-POSTFIX GRIND)
  355. (DEFPROP MFACTORIAL 160. LBP)
  356.  
  357. (DEFPROP MEXPT MSZ-MEXPT GRIND)
  358. (DEFPROP MEXPT 140. LBP)
  359. (DEFPROP MEXPT 139. RBP)
  360.  
  361. (DEFUN MSZ-MEXPT (X L R)
  362.   (SETQ L (MSIZE (CADR X) L NIL LOP 'MEXPT)
  363.     R (IF (MMMINUSP (SETQ X (NFORMAT (CADDR X))))
  364.           (MSIZE (CADR X) (REVERSE '(#\^ #\-)) R 'MEXPT ROP)
  365.           (MSIZE X (LIST #\^) R 'MEXPT ROP)))
  366.   (LIST (f+ (CAR L) (CAR R)) L R))
  367.  
  368.  
  369. (DEFPROP MNCEXPT MSIZE-INFIX GRIND)
  370. (DEFPROP MNCEXPT 135. LBP)
  371. (DEFPROP MNCEXPT 134. RBP)
  372.  
  373. (DEFPROP MNCTIMES MSIZE-NARY GRIND)
  374. (DEFPROP MNCTIMES 110. LBP)
  375. (DEFPROP MNCTIMES 109. RBP)
  376.  
  377. (DEFPROP MTIMES MSZ-MTIMES GRIND)
  378. (DEFPROP MTIMES 120. LBP)
  379. (DEFPROP MTIMES 120. RBP)
  380.  
  381. (DEFUN MSZ-MTIMES (X L R) (MSZNARY X L R '(#\*)))
  382.  
  383.  
  384. (DEFPROP MQUOTIENT MSIZE-INFIX GRIND)
  385. (DEFPROP MQUOTIENT 120. LBP)
  386. (DEFPROP MQUOTIENT 121. RBP) 
  387. (DEFPROP RAT MSIZE-INFIX GRIND)
  388. (DEFPROP RAT 120. LBP)
  389. (DEFPROP RAT 121. RBP)
  390.  
  391. (DEFPROP MPLUS MSZ-MPLUS GRIND)
  392. (DEFPROP MPLUS 100. LBP)
  393. (DEFPROP MPLUS 100. RBP)
  394.  
  395. (DEFUN MSZ-MPLUS (X L R)
  396.  (COND ((NULL (CDDR X))
  397.     (IF (NULL (CDR X))
  398.         (MSIZE-FUNCTION X L R T)
  399.         (MSIZE (CADR X) (APPEND (NCONS #\+) L) R 'MPLUS ROP)))
  400.        (T (SETQ L (MSIZE (CADR X) L NIL LOP 'MPLUS) X (CDDR X))
  401.       (DO ((NL (LIST L)) (W (CAR L)) (DISSYM))
  402.           ((NULL (CDR X))
  403.            (IF (MMMINUSP (CAR X)) (SETQ L (CADAR X) DISSYM (LIST #\-))
  404.            (SETQ L (CAR X) DISSYM (LIST #\+)))
  405.            (SETQ R (MSIZE L DISSYM R 'MPLUS ROP))
  406.            (CONS (f+ (CAR R) W) (NREVERSE (CONS R NL))))
  407.          (DECLARE (FIXNUM W))
  408.           (IF (MMMINUSP (CAR X)) (SETQ L (CADAR X) DISSYM (LIST #\-))
  409.           (SETQ L (CAR X) DISSYM (LIST #\+)))
  410.           (SETQ NL (CONS (MSIZE L DISSYM NIL 'MPLUS 'MPLUS) NL)
  411.             W (f+ (CAAR NL) W)
  412.             X (CDR X))))))
  413.  
  414. (DEFPROP MMINUS MSIZE-PREFIX GRIND)
  415. (DEFPROP MMINUS (#\-) STRSYM)
  416. (DEFPROP MMINUS 100. RBP)
  417. (DEFPROP MMINUS 100. LBP)
  418.  
  419. (DEFPROP MEQUAL MSIZE-INFIX GRIND)
  420. (DEFPROP MEQUAL 80. LBP)
  421. (DEFPROP MEQUAL 80. RBP)
  422.  
  423. (DEFPROP MNOTEQUAL MSIZE-INFIX GRIND)
  424. (DEFPROP MNOTEQUAL 80. LBP)
  425. (DEFPROP MNOTEQUAL 80. RBP)
  426.  
  427. (DEFPROP MGREATERP MSIZE-INFIX GRIND)
  428. (DEFPROP MGREATERP 80. LBP)
  429. (DEFPROP MGREATERP 80. RBP)
  430.  
  431. (DEFPROP MGEQP MSIZE-INFIX GRIND)
  432. (DEFPROP MGEQP 80. LBP)
  433. (DEFPROP MGEQP 80. RBP)
  434.  
  435. (DEFPROP MLESSP MSIZE-INFIX GRIND)
  436. (DEFPROP MLESSP 80. LBP)
  437. (DEFPROP MLESSP 80. RBP)
  438.  
  439. (DEFPROP MLEQP MSIZE-INFIX GRIND)
  440. (DEFPROP MLEQP 80. LBP)
  441. (DEFPROP MLEQP 80. RBP)
  442.  
  443. (DEFPROP MNOT MSIZE-PREFIX GRIND)
  444. (DEFPROP MNOT 70. RBP)
  445.  
  446. (DEFPROP MAND MSIZE-NARY GRIND)
  447. (DEFPROP MAND 60. LBP)
  448. (DEFPROP MAND 60. RBP)
  449.  
  450. (DEFPROP MOR MSIZE-NARY GRIND)
  451. (DEFPROP MOR 50. LBP)
  452. (DEFPROP MOR 50. RBP)
  453.  
  454. (DEFPROP MCOND MSZ-MCOND GRIND)
  455. (DEFPROP MCOND 25. LBP)
  456. (DEFPROP MCOND 25. RBP)
  457.  
  458. (DEFUN MSZ-MCOND (X L R &AUX IF)
  459.     (SETQ IF (NRECONC L '(#\I #\F #\SPACE)) IF (CONS (LENGTH IF) IF)
  460.       L (MSIZE (CADR X) NIL NIL 'MCOND 'MPAREN))
  461.     (COND ((EQ '$FALSE (FIFTH X))
  462.        (SETQ X (MSIZE (CADDR X)
  463.               (REVERSE '(#\SPACE #\T #\H #\E #\N #\SPACE))
  464.               R 'MCOND ROP))
  465.        (LIST (f+ (CAR IF) (CAR L) (CAR X)) IF L X))
  466.       (T (SETQ R (MSIZE (FIFTH X)
  467.                 (REVERSE '(#\SPACE #\E #\L #\S #\E #\SPACE))
  468.                 R 'MCOND ROP)
  469.            X (MSIZE (CADDR X)
  470.                 (REVERSE '(#\SPACE #\T #\H #\E #\N #\SPACE))
  471.                 NIL 'MCOND 'MPAREN))
  472.          (LIST (f+ (CAR IF) (CAR L) (CAR X) (CAR R)) IF L X R))))
  473.  
  474. (defprop text-string msize-text-string grind)
  475. (defun msize-text-string (x l r)
  476.   (cons (length (cdr x)) (cdr x))
  477.   )
  478.  
  479. (DEFPROP MDO MSZ-MDO GRIND)
  480. (DEFPROP MDO 30. LBP)
  481. (DEFPROP MDO 30. RBP)
  482. (DEFPROP MDOIN MSZ-MDOIN GRIND)
  483. (DEFPROP MDOIN 30. RBP)
  484.  
  485. (DEFUN MSZ-MDO (X L R)
  486.   (MSZNARY (CONS '(MDO) (STRMDO X)) L R '(#\SPACE)))
  487.  
  488. (DEFUN MSZ-MDOIN (X L R)
  489.   (MSZNARY (CONS '(MDO) (STRMDOIN X)) L R '(#\SPACE)))
  490.  
  491. (DEFUN STRMDO (X)
  492.   (NCONC (COND ((SECOND X) `($FOR ,(SECOND X))))
  493.      (COND ((EQUAL 1 (THIRD X)) NIL)
  494.            ((THIRD X)  `($FROM ,(THIRD X))))
  495.      (COND ((EQUAL 1 (FOURTH X)) NIL)
  496.            ((FOURTH X) `($STEP ,(FOURTH X)))
  497.            ((FIFTH X)  `($NEXT ,(FIFTH X))))
  498.      (COND ((SIXTH X)  `($THRU ,(SIXTH X))))
  499.      (COND ((NULL (SEVENTH X)) NIL)
  500.            ((EQ 'MNOT (CAAR (SEVENTH X)))
  501.         `($WHILE ,(CADR (SEVENTH X))))
  502.            (T `($UNLESS ,(SEVENTH X))))
  503.      `($DO ,(EIGHTH X))))
  504.  
  505. (DEFUN STRMDOIN (X)
  506.   (NCONC `($FOR ,(SECOND X) $IN ,(THIRD X))
  507.      (COND ((SIXTH X) `($THRU ,(SIXTH X))))
  508.      (COND ((NULL (SEVENTH X)) NIL)
  509.            ((EQ 'MNOT (CAAR (SEVENTH X)))
  510.         `($WHILE ,(CADR (SEVENTH X))))
  511.            (T `($UNLESS ,(SEVENTH X))))
  512.      `($DO ,(EIGHTH X))))
  513.  
  514.  
  515.  
  516.